home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / os2 / pvm34b3.zip / pvm34b3 / pvm3 / examples / hitc_slave.f < prev    next >
Text File  |  1997-07-22  |  9KB  |  326 lines
  1. c
  2. c $Id: hitc_slave.f,v 1.1 1996/09/23 20:55:32 pvmsrc Exp $
  3. c
  4.       program hitc_slave
  5.       include '../include/fpvm3.h'
  6. c ------------------------------------------------------
  7. c Slave performs work requested by the master
  8. c ------------------------------------------------------
  9.       parameter(iplmax=3,ipkkr=(iplmax+1)**2,ipbase=5)
  10.       parameter(iprkkr=ipkkr*2,iprmtr=iprkkr*ipbase)
  11. c
  12.       integer  info, mytid, mtid, msgtype
  13.       real*8   random
  14.       complex*16  amt(iprmtr,iprmtr),bmt(iprmtr,iprmtr)
  15.  
  16. c  Enroll this program in PVM 
  17.       call pvmfmytid( mytid )
  18. c  Get the master's task id
  19.       call pvmfparent( mtid )
  20.  
  21. c ------- Begin work loop -------- 
  22.  
  23.    1  continue
  24. c     Receive data from host 
  25.       msgtype  = 1 
  26.       call pvmfrecv( mtid, msgtype, info ) 
  27.       call pvmfunpack( INTEGER4, n, 1, 1, info )
  28.  
  29. c     Check if problem is over
  30.       if( n .lt. 1 ) goto 9999
  31.  
  32. c     Generate matrix of given size
  33.       do 20 i=1,n
  34.         do 10 j=1,n
  35.           amt(i,j) = random()
  36.           bmt(i,j) = cmplx(0.d0,0.d0)
  37.   10    continue
  38.   20  continue
  39.  
  40. c     Calculate Matrix Inverse
  41.       call matinv( n, amt, bmt ) 
  42.                     
  43. c     Send result to host 
  44.       call pvmfinitsend( PVMDEFAULT, info )
  45.       call pvmfpack( INTEGER4, mytid, 1, 1, info )
  46.       msgtype  = 2 
  47.       call pvmfsend( mtid, msgtype, info ) 
  48.  
  49. c     Go To top and await more work.
  50.       goto 1
  51. 9999  continue
  52.       print *,mytid,' received no-more-work flag: exiting...'
  53.       call pvmfexit(info) 
  54.       stop
  55.       end
  56.  
  57. c    ==================================================================
  58. c
  59.       subroutine matinv( nrmatr, amt, bmt )
  60. c
  61. c    ==================================================================
  62. c
  63.       implicit real*8 (a-h,o-z)
  64. c
  65.        parameter(iplmax=3,ipkkr=(iplmax+1)**2,ipbase=5)
  66.        parameter(iprkkr=ipkkr*2,iprmtr=iprkkr*ipbase)
  67. c
  68.       complex*16  amt(iprmtr,iprmtr),bmt(iprmtr,iprmtr)
  69.       complex*16  td(iprmtr),ad(iprmtr),bd(iprmtr)
  70.       complex*16  amtinv,m1
  71. c
  72. c     **************************************************************
  73. c     calculates the matrix inverse needed to determine
  74. c     elements of the tau-matrix.
  75. c
  76. c     Level 2 BLAS version...............................
  77. c     **************************************************************
  78.          m1=(-1.00d+00,0.0d+00)
  79. c
  80. c        general case............
  81.          do 16 i=1,nrmatr
  82.             amtinv=1.0d+00/amt(i,i)
  83.             do 12 j=1,i
  84.                bd(j)=bmt(i,j)
  85.                td(j)=amtinv*amt(j,i)
  86.  12         continue
  87.             ad(i)=amt(i,i)
  88.             td(i)=(0.0d+00,0.0d+00)
  89.             do 13 j=i+1,nrmatr
  90.                ad(j)=amt(i,j)
  91.  13            td(j)=amtinv*amt(j,i)
  92. c
  93. c  level 2  blas
  94. c
  95.         call zgeru(nrmatr,i,m1,td,1,bd,1,bmt,iprmtr)
  96.         call zgeru(nrmatr,nrmatr-i+1,m1,td,1,ad(i),1,amt(1,i),iprmtr)
  97. c
  98.  16      continue
  99. c
  100.       return
  101.       end
  102.  
  103. ************************************************************************
  104. *
  105.       SUBROUTINE ZGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
  106. *     .. Scalar Arguments ..
  107.       COMPLEX*16         ALPHA
  108.       INTEGER            INCX, INCY, LDA, M, N
  109. *     .. Array Arguments ..
  110.       COMPLEX*16         A( LDA, * ), X( * ), Y( * )
  111. *     ..
  112. *
  113. *  Purpose
  114. *  =======
  115. *
  116. *  ZGERU  performs the rank 1 operation
  117. *
  118. *     A := alpha*x*y' + A,
  119. *
  120. *  where alpha is a scalar, x is an m element vector, y is an n element
  121. *  vector and A is an m by n matrix.
  122. *
  123. *  Parameters
  124. *  ==========
  125. *
  126. *  M      - INTEGER.
  127. *           On entry, M specifies the number of rows of the matrix A.
  128. *           M must be at least zero.
  129. *           Unchanged on exit.
  130. *
  131. *  N      - INTEGER.
  132. *           On entry, N specifies the number of columns of the matrix A.
  133. *           N must be at least zero.
  134. *           Unchanged on exit.
  135. *
  136. *  ALPHA  - COMPLEX*16      .
  137. *           On entry, ALPHA specifies the scalar alpha.
  138. *           Unchanged on exit.
  139. *
  140. *  X      - COMPLEX*16       array of dimension at least
  141. *           ( 1 + ( m - 1 )*abs( INCX ) ).
  142. *           Before entry, the incremented array X must contain the m
  143. *           element vector x.
  144. *           Unchanged on exit.
  145. *
  146. *  INCX   - INTEGER.
  147. *           On entry, INCX specifies the increment for the elements of
  148. *           X. INCX must not be zero.
  149. *           Unchanged on exit.
  150. *
  151. *  Y      - COMPLEX*16       array of dimension at least
  152. *           ( 1 + ( n - 1 )*abs( INCY ) ).
  153. *           Before entry, the incremented array Y must contain the n
  154. *           element vector y.
  155. *           Unchanged on exit.
  156. *
  157. *  INCY   - INTEGER.
  158. *           On entry, INCY specifies the increment for the elements of
  159. *           Y. INCY must not be zero.
  160. *           Unchanged on exit.
  161. *
  162. *  A      - COMPLEX*16       array of DIMENSION ( LDA, n ).
  163. *           Before entry, the leading m by n part of the array A must
  164. *           contain the matrix of coefficients. On exit, A is
  165. *           overwritten by the updated matrix.
  166. *
  167. *  LDA    - INTEGER.
  168. *           On entry, LDA specifies the first dimension of A as declared
  169. *           in the calling (sub) program. LDA must be at least
  170. *           max( 1, m ).
  171. *           Unchanged on exit.
  172. *
  173. *
  174. *  Level 2 Blas routine.
  175. *
  176. *  -- Written on 22-October-1986.
  177. *     Jack Dongarra, Argonne National Lab.
  178. *     Jeremy Du Croz, Nag Central Office.
  179. *     Sven Hammarling, Nag Central Office.
  180. *     Richard Hanson, Sandia National Labs.
  181. *
  182. *
  183. *     .. Parameters ..
  184.       COMPLEX*16         ZERO
  185.       PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
  186. *     .. Local Scalars ..
  187.       COMPLEX*16         TEMP
  188.       INTEGER            I, INFO, IX, J, JY, KX
  189. *     .. External Subroutines ..
  190.       EXTERNAL           XERBLA
  191. *     .. Intrinsic Functions ..
  192.       INTRINSIC          MAX
  193. *     ..
  194. *     .. Executable Statements ..
  195. *
  196. *     Test the input parameters.
  197. *
  198.       INFO = 0
  199.       IF     ( M.LT.0 )THEN
  200.          INFO = 1
  201.       ELSE IF( N.LT.0 )THEN
  202.          INFO = 2
  203.       ELSE IF( INCX.EQ.0 )THEN
  204.          INFO = 5
  205.       ELSE IF( INCY.EQ.0 )THEN
  206.          INFO = 7
  207.       ELSE IF( LDA.LT.MAX( 1, M ) )THEN
  208.          INFO = 9
  209.       END IF
  210.       IF( INFO.NE.0 )THEN
  211.          CALL XERBLA( 'ZGERU ', INFO )
  212.          RETURN
  213.       END IF
  214. *
  215. *     Quick return if possible.
  216. *
  217.       IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
  218.      $   RETURN
  219. *
  220. *     Start the operations. In this version the elements of A are
  221. *     accessed sequentially with one pass through A.
  222. *
  223.       IF( INCY.GT.0 )THEN
  224.          JY = 1
  225.       ELSE
  226.          JY = 1 - ( N - 1 )*INCY
  227.       END IF
  228.       IF( INCX.EQ.1 )THEN
  229.          DO 20, J = 1, N
  230.             IF( Y( JY ).NE.ZERO )THEN
  231.                TEMP = ALPHA*Y( JY )
  232.                DO 10, I = 1, M
  233.                   A( I, J ) = A( I, J ) + X( I )*TEMP
  234.    10          CONTINUE
  235.             END IF
  236.             JY = JY + INCY
  237.    20    CONTINUE
  238.       ELSE
  239.          IF( INCX.GT.0 )THEN
  240.             KX = 1
  241.          ELSE
  242.             KX = 1 - ( M - 1 )*INCX
  243.          END IF
  244.          DO 40, J = 1, N
  245.             IF( Y( JY ).NE.ZERO )THEN
  246.                TEMP = ALPHA*Y( JY )
  247.                IX   = KX
  248.                DO 30, I = 1, M
  249.                   A( I, J ) = A( I, J ) + X( IX )*TEMP
  250.                   IX        = IX        + INCX
  251.    30          CONTINUE
  252.             END IF
  253.             JY = JY + INCY
  254.    40    CONTINUE
  255.       END IF
  256. *
  257.       RETURN
  258. *
  259. *     End of ZGERU .
  260. *
  261.       END
  262.       SUBROUTINE XERBLA ( SRNAME, INFO )
  263. *     ..    Scalar Arguments ..
  264.       INTEGER            INFO
  265.       CHARACTER*6        SRNAME
  266. *     ..
  267. *
  268. *  Purpose
  269. *  =======
  270. *
  271. *  XERBLA  is an error handler for the Level 2 BLAS routines.
  272. *
  273. *  It is called by the Level 2 BLAS routines if an input parameter is
  274. *  invalid.
  275. *
  276. *  Installers should consider modifying the STOP statement in order to
  277. *  call system-specific exception-handling facilities.
  278. *
  279. *  Parameters
  280. *  ==========
  281. *
  282. *  SRNAME - CHARACTER*6.
  283. *           On entry, SRNAME specifies the name of the routine which
  284. *           called XERBLA.
  285. *
  286. *  INFO   - INTEGER.
  287. *           On entry, INFO specifies the position of the invalid
  288. *           parameter in the parameter-list of the calling routine.
  289. *
  290. *
  291. *  Auxiliary routine for Level 2 Blas.
  292. *
  293. *  Written on 20-July-1986.
  294. *
  295. *     .. Executable Statements ..
  296. *
  297.       WRITE (*,99999) SRNAME, INFO
  298. *
  299.       STOP
  300. *
  301. 99999 FORMAT ( ' ** On entry to ', A6, ' parameter number ', I2,
  302.      $         ' had an illegal value' )
  303. *
  304. *     End of XERBLA.
  305. *
  306.       END
  307.  
  308. c-----------------------------------------------------------------------------
  309.       double precision function random()
  310.  
  311. c-----------------------------------------------------
  312. c  Routine returns a pseudo-random number between 0-1. 
  313. c-----------------------------------------------------
  314.       integer m, i, md, seed
  315.       double precision fmd
  316.  
  317.       data m/25173/,i/13849/,md/65536/,fmd/65536.d0/,seed/17/
  318.  
  319.       save seed
  320.  
  321.       seed   = mod(m*seed+i,md)
  322.       random = seed/fmd
  323.       return
  324.       end
  325.  
  326.